home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / package.tcl < prev    next >
Encoding:
Text File  |  2001-02-01  |  44.7 KB  |  1,485 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "package.tcl"
  6.  #                                    created: 2/8/97 {6:15:10 pm} 
  7.  #                                last update: 02/01/2001 {09:32:54 AM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta, Santa Fe, NM 87501
  11.  #     www: <http://www.santafe.edu/~vince/>
  12.  #  
  13.  # Copyright (c) 1997-2000  Vince Darley, all rights reserved
  14.  # 
  15.  #  How to ensure packages are loaded in the correct order?
  16.  #  (some may require Vince's Additions).  Here perhaps we could
  17.  #  just use a Tcl8-like-approach: introduce a 'package' command
  18.  #  and have stuff like 'package Name 1.0 script-to-load'.
  19.  #  Then a package can just do 'package require Othername' to ensure
  20.  #  it is loaded.  I like this approach.
  21.  #  
  22.  #  How to initialise each package at startup?  If we use the above
  23.  #  scheme, then the startup script is purely a sequence of
  24.  #  'package require Name' commands.  The file 'prefs.tcl' is then
  25.  #  purely for user-meddling.  Packages do not need to store anything
  26.  #  there.  Sounds good to me.
  27.  #  
  28.  #  How to uninstall things?  One approach here is a 
  29.  #  'package uninstall Name' command.  Nice packages would provide
  30.  #  this.
  31.  #  
  32.  #  We need a default behaviour too.  Some packages require no
  33.  #  installation at all (except placing in a directory), others 
  34.  #  require sourcing, others need to add something to a menu.  How
  35.  #  much of this should be automated and how much is up to the
  36.  #  package author?
  37.  # 
  38.  # ----
  39.  # 
  40.  #  The solution below is to imitate Tcl 8.  There is a 'package'
  41.  #  mechanism.  There exists a index::feature() array which gives for
  42.  #  each package the means to load it --- a procedure name or a
  43.  #  'source file' command.  The package index is compiled 
  44.  #  automatically by recursively scanning all files in the
  45.  #  Packages directory for 'package name version do-this'
  46.  #  commands.
  47.  #  
  48.  #  There's also 'package names', 'package exists name', and an
  49.  #  important 'package require name version' which allows one
  50.  #  package to autoload another...
  51.  #  
  52.  # Pros of this approach: many packages, which would otherwise
  53.  # require an installation procedure, now can be just dropped
  54.  # in to the packages directory and they're installed! (After
  55.  # rebuilding the package index).  This is because 'package'
  56.  # can declare a snippet of code, an addition to a menu etc…
  57.  # ----
  58.  # 
  59.  # Thanks to Tom Fetherston for some improvements here.
  60.  # ###################################################################
  61.  ##
  62.  
  63. namespace eval package {}
  64. namespace eval date {}
  65. namespace eval remote {}
  66.  
  67. set package::loaded [list]
  68.  
  69. ## 
  70.  # -------------------------------------------------------------------------
  71.  # 
  72.  # "alpha::findAllExtensions" --
  73.  # 
  74.  #  package require all extensions the user has activated
  75.  # -------------------------------------------------------------------------
  76.  ##
  77. proc alpha::findAllExtensions {} {
  78.     global global::features index::feature alpha::earlyPackages
  79.     foreach m [array names index::feature] {
  80.     if {[lsearch -exact [set global::features] $m] != -1} {
  81.         # it's on
  82.         if {[lsearch -exact [set alpha::earlyPackages] $m] != -1} {
  83.         # We already did this one.
  84.         continue
  85.         }
  86.         package::activate $m
  87.     } else {
  88.         if {[lindex [set index::feature($m)] 2] == 2} {
  89.         package::initialise $m
  90.         }
  91.     }
  92.     }
  93.  
  94.     # remove any package which doesn't exist.
  95.     foreach m [set global::features] {
  96.     if {![info exists index::feature($m)]} {
  97.         set global::features [lremove ${global::features} $m]
  98.     }
  99.     }
  100. }
  101.  
  102. ## 
  103.  # -------------------------------------------------------------------------
  104.  # 
  105.  # "package::addPrefsDialog" --
  106.  # 
  107.  #  Register a given package as having a standard preferences page which
  108.  #  should be accessible from the 'Config->Packages' menu.  If the optional
  109.  #  'mapTo' argument is given, then the actual preferences data is not
  110.  #  stored in the array variable ${pkg}modeVars, but rather in 
  111.  #  ${mapTo}modeVars.  This is useful if the 'pkg' name is rather long..
  112.  # -------------------------------------------------------------------------
  113.  ##
  114. if {[info tclversion] < 8.0} {
  115. proc package::addPrefsDialog {pkg {mapTo ""}} {
  116.     global package::prefs alpha::noMenusYet alpha::prefs
  117.     if {[string length $mapTo]} {
  118.     set alpha::prefs($pkg) $mapTo
  119.     }
  120.     lunion package::prefs $pkg
  121.     if {![info exists alpha::noMenusYet]} {
  122.     # we were called after start-up; build the menu now
  123.     menu::buildSome packages
  124.     }
  125. }
  126. } else {
  127. proc package::addPrefsDialog {pkg {mapTo ""}} {
  128.     global package::prefs alpha::noMenusYet
  129.     if {[string length $mapTo]} {
  130.     # I think the existence of two variables *::prefs in this proc
  131.     # causes problems, especially with lunion's upvar call.
  132.     set ::alpha::prefs($pkg) $mapTo
  133.     }
  134.     lunion package::prefs $pkg
  135.     if {![info exists alpha::noMenusYet]} {
  136.     # we were called after start-up; build the menu now
  137.     menu::buildSome packages
  138.     }
  139. }
  140. }
  141.  
  142. ## 
  143.  # -------------------------------------------------------------------------
  144.  # 
  145.  # "alpha::package" --
  146.  # 
  147.  #  Mimics the Tcl standard 'package' command for use with Alpha.
  148.  #  It does however have some differences.
  149.  #  
  150.  #  package require ?-exact? ?-extension -mode -menu? name version
  151.  #  package exists ?-extension -mode -menu? name version
  152.  #  package names ?-extension -mode -menu?
  153.  #  package uninstall name version
  154.  #  package vcompare v1 v2
  155.  #  package vsatisfies v1 v2
  156.  #  package versions ?-extension -mode -menu? name
  157.  #  package type name
  158.  #  package info name
  159.  #  package maintainer name version {name email web-page}
  160.  #  package modes 
  161.  #  
  162.  #  Equivalent to alpha::mode alpha::menu and alpha::extension
  163.  #  
  164.  #  package mode ...
  165.  #  package menu ...
  166.  #  package extension ...
  167.  #  
  168.  #  For extensions only:
  169.  #  
  170.  #  package forget name version
  171.  # -------------------------------------------------------------------------
  172.  ##
  173. proc alpha::package {cmd args} {
  174.     global index::feature
  175.     switch -- $cmd {
  176.     "require" {
  177.         set info [package::getInfo "exact loose"]
  178.         global alpha::rebuilding
  179.         if {[llength $info]} {
  180.         if {!${alpha::rebuilding} && [set version [lindex $args 1]] != ""} {
  181.             if {[info exists exact]} {
  182.             if {[lindex $info 0] != $version} {
  183.                 error "requested exact $version, had [lindex $info 0]"
  184.             }
  185.             } elseif {[info exists loose]} {
  186.             if {[alpha::package vcompare [lindex $info 0] $version] < 0} {
  187.                 error "requested $version or newer, had [lindex $info 0]"
  188.             }
  189.             } elseif {![alpha::package vsatisfies [lindex $info 0] $version]} {
  190.             error "requested $version, had [lindex $info 0]"
  191.             }
  192.         }
  193.         if {$type == "feature"} {
  194.             global global::features package::loaded
  195.             if {[lsearch -exact [set package::loaded] $name] == -1} {
  196.             lappend package::loaded $name
  197.             package::activate $name
  198.             }
  199.             if {[lsearch -exact ${global::features} $name] == -1} {
  200.             lappend global::features $name
  201.             }
  202.         }
  203.         return [lindex $info 0]
  204.         }
  205.         if {!${alpha::rebuilding}} {
  206.         error "can't find package $name"
  207.         }
  208.     }
  209.     "uninstall" {
  210.         set name [lindex $args 0]
  211.         if {[llength $args] > 2} {
  212.         set version [lindex $args 1]
  213.         global alpha::rebuilding 
  214.         if {${alpha::rebuilding}} {
  215.             global rebuild_cmd_count index::uninstall pkg_file
  216.             switch -- [set script [lindex $args 2]] {
  217.             "this-file" {
  218.                 set script [alpha::actionOnFileScript "file delete" $pkg_file]
  219.             }
  220.             "this-directory" {
  221.                 set script [alpha::actionOnFileScript "rm -r" [file dirname $pkg_file]]
  222.             }
  223.             }
  224.             set index::uninstall($name) [list $version \
  225.               [string trim [alpha::actionOnFileScript "" $pkg_file]] $script]
  226.             set args [lrange $args 3 end]
  227.             if {[llength $args]} {
  228.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  229.             return
  230.             }
  231.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  232.             return -code 11
  233.             }
  234.         }
  235.         } else {
  236.         global index::uninstall
  237.         cache::readContents index::uninstall
  238.         set ret [set index::uninstall($name)]
  239.         catch {unset index::uninstall}
  240.         return $ret
  241.         }
  242.     }
  243.     "forget" {
  244.         catch {unset index::feature($name)}
  245.     }
  246.     "exists" {
  247.         if {[package::getInfo] != ""} {return 1} else {return 0}
  248.     }
  249.     "type" {
  250.         if {[package::getInfo] != ""} {return $type} 
  251.         error "No such package"
  252.     }
  253.     "info" {
  254.         if {[llength [set info [package::getInfo]]]} {return [concat $type $info]} 
  255.         error "No such package"
  256.     }
  257.     "preinit" -
  258.     "maintainer" -
  259.     "disable" -
  260.     "description" -
  261.     "help" {
  262.         set name [lindex $args 0]
  263.         if {[llength $args] > 2} {
  264.         global alpha::rebuilding 
  265.         if {${alpha::rebuilding}} {
  266.             set version [lindex $args 1]
  267.             global rebuild_cmd_count index::$cmd
  268.             set data [lindex $args 2]
  269.             set index::${cmd}($name) [list $version $data]
  270.             set args [lrange $args 3 end]
  271.             if {[llength $args]} {
  272.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  273.             return
  274.             }
  275.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  276.             return -code 11
  277.             }
  278.         }
  279.         } else {
  280.         cache::readContents index::$cmd
  281.         return [set index::${cmd}($name)]
  282.         }
  283.     }
  284.     "versions" {
  285.         set info [package::getInfo]
  286.         if {[llength $info]} {
  287.         return [lindex $info 0]
  288.         }
  289.         error "No such package"
  290.     }
  291.     "vcompare" {
  292.         set c [eval package::_versionCompare $args]
  293.         if {$c > 0 || $c == -3} {
  294.         return 1
  295.         } elseif {$c == 0} {
  296.         return 0
  297.         } else {
  298.         return -1
  299.         }
  300.     }
  301.     "vsatisfies" {
  302.         if {[lindex $args 0] == "-loose"} {
  303.         set c [eval package::_versionCompare [lrange $args 1 end]]
  304.         return [expr {$c >= 0 || $c == -3 ? 1 : 0}]
  305.         } else {
  306.         set c [eval package::_versionCompare $args]
  307.         return [expr {$c >= 0 ? 1 : 0}]
  308.         }
  309.     }
  310.     "names" {
  311.         set names ""
  312.         package::getInfo
  313.         foreach type $which {
  314.         if {[array exists index::${type}]} {
  315.             eval lappend names [array names index::${type}]
  316.         }
  317.         }
  318.         return $names
  319.     }
  320.     "mode" -
  321.     "menu" -
  322.     "feature" {
  323.         eval alpha::$cmd $args
  324.     }
  325.     default {
  326.         error "Unknown option '$cmd' to 'package'"
  327.     }
  328.     }
  329. }
  330.  
  331. proc package::getInfo {{flags ""}} {
  332.     uplevel [list set flags $flags]
  333.     uplevel {
  334.     set name [lindex $args 0]
  335.     if {[regexp -- {-([^-].*)} $name "" which]} {
  336.         if {[lsearch $flags $which] != -1} {
  337.         set $which 1
  338.         set name [lindex $args 1]            
  339.         set args [lrange $args 1 end]            
  340.         return [package::getInfo $flags]
  341.         }
  342.         if {[lsearch {feature mode} $which] == -1} {
  343.         error "No such flag -$which"
  344.         }
  345.         set name [lindex $args 1]
  346.         set args [lrange $args 1 end]
  347.     } else {
  348.         set which {feature mode}
  349.     }
  350.     foreach type $which {
  351.         if {$type != "feature"} {cache::readContents index::${type}}
  352.         if {[info exists index::${type}($name)]} {
  353.         return [set index::${type}($name)]
  354.         }
  355.     }
  356.     return ""
  357.     }    
  358. }
  359.  
  360. ## 
  361.  # -------------------------------------------------------------------------
  362.  # 
  363.  # "package::_versionCompare" --
  364.  # 
  365.  #  This proc compares the two version numbers.  It returns:
  366.  #  
  367.  #  0 equal
  368.  #  1 equal but beta/patch update
  369.  #  2 equal but minor update
  370.  #  -1 beta/patch version older
  371.  #  -2 minor version older
  372.  #  -3 major version newer
  373.  #  -5 major version older
  374.  #  
  375.  #  i.e. >= 0 is basically ok, < 0 basically bad
  376.  #  
  377.  #  It works for beta, alpha, dev, fc and patch version numbers.
  378.  #  Any sequence of letters starting b,a,d,f,p are assumed to
  379.  #  represent the particular item.
  380.  #  
  381.  #  2.4 > 1.5 > 1.4.3 > 1.4.3b2 > 1.4.3b1 > 1.4.3a75 > 1.4p1 > 1.4
  382.  # -------------------------------------------------------------------------
  383.  ##
  384. proc package::_versionCompare {v1 v2} {
  385.     regsub -all -nocase {([a-z])[a-z]+} $v1 {\1} v1
  386.     regsub -all -nocase {([a-z])[a-z]+} $v2 {\1} v2
  387.     set v1 [split $v1 .p]
  388.     set v2 [split $v2 .p]
  389.     set i -1
  390.     set ret 0
  391.     set mult 2
  392.     while 1 {
  393.     incr i
  394.     set sv1 [lindex $v1 0]
  395.     set sv2 [lindex $v2 0]
  396.     if {$sv1 == "" && $sv2 == ""} { break }
  397.     if {$sv1 == ""} { 
  398.         set v1 [concat 8 0 $v1]
  399.         set v2 [concat 9 $v2]
  400.         continue
  401.     } elseif {$sv2 == ""} { 
  402.         set v1 [concat 9 $v1]
  403.         set v2 [concat 8 0 $v2]
  404.         continue
  405.     } elseif {[regexp -nocase {[a-z]} "$sv1$sv2"]} {
  406.         # beta versions
  407.         foreach v {sv1 sv2} {
  408.         if {[regexp -nocase {[a-z]} [set $v]]} {
  409.             # f = 8, b = 7, a = 6, d = 5
  410.             regsub -nocase {([^a-z])f} [set $v] {\1 7 } $v
  411.             regsub -nocase {([^a-z])b} [set $v] {\1 6 } $v
  412.             regsub -nocase {([^a-z])a} [set $v] {\1 5 } $v
  413.             regsub -nocase {([^a-z])d} [set $v] {\1 4 } $v
  414.         } else {
  415.             # release version = 8, so it is larger than any of the above
  416.             append $v " 8"
  417.         }
  418.         }
  419.         set v1 [eval lreplace [list $v1] 0 0 $sv1]
  420.         set v2 [eval lreplace [list $v2] 0 0 $sv2]
  421.         set mult 1
  422.         continue
  423.     }
  424.     if {$sv1 < $sv2} { set ret -1 ; break }
  425.     if {$sv1 > $sv2} { set ret 1 ; break }
  426.     set v1 [lrange $v1 1 end]
  427.     set v2 [lrange $v2 1 end]
  428.     }
  429.     if {$i == 0} {
  430.     # major version, return 0, -3, -5
  431.     return [expr {$ret * (-4*$ret + 1)}]
  432.     } else {
  433.     return [expr {$mult *$ret}]
  434.     }
  435. }
  436.  
  437. proc package::versionCheck {name vers} {
  438.     set av [alpha::package versions $name]
  439.     set c [package::_versionCompare $av $vers]
  440.     if {$c < 0 && $c != -3} {            
  441.     error "The installed version $av of '$name' is too old. Version $vers was requested."
  442.     } elseif {$c == -3} {            
  443.     error "The installed version $av of '$name' may not be backwards compatible with the requested version ($vers)."
  444.     }            
  445. }
  446.  
  447. proc package::reqInstalledVersion {name exact? {reqvers ""}} {
  448.     global index::feature
  449.     # called from installer
  450.     set msg " I suggest you abort the installation."
  451.     if {[info exists index::feature($name)]} {
  452.     if {[set exact?] == ""} {return}
  453.     set av [alpha::package versions $name]
  454.     if {[set exact?] == "-exact"} {
  455.         if {[alpha::package versions $name] != $reqvers} {
  456.         alertnote "The installed version $av of '$name' is incorrect.  Exact version $reqvers was requested.$msg"
  457.         }
  458.     } else {
  459.         set reqvers [set exact?]
  460.         if {$reqvers != ""} {        
  461.         set c [package::_versionCompare $av $reqvers]            
  462.         if {$c < 0 && $c != -3} {            
  463.             alertnote "The installed version $av of '$name' is too old. Version $reqvers was requested.$msg"
  464.         } elseif {$c == -3} {            
  465.             alertnote "The installed version $av of '$name' may not be backwards compatible with the requested version ($reqvers).$msg"
  466.         }             
  467.         }        
  468.     }
  469.     } else {
  470.     alertnote "This package requires the prior installation of '$name'. It is not currently installed.$msg"
  471.     }
  472. }
  473.  
  474. proc package::checkRequire {pkg} {
  475.     if {[catch {alpha::package require $pkg} error]} {
  476.     global errorInfo ; echo $errorInfo
  477.     if {[catch {alertnote "The '$pkg' package had an error starting up: $error"} ]} {
  478.         alertnote "The '$pkg' package had an error starting up"
  479.         echo $error
  480.     }
  481.     }    
  482. }
  483.  
  484.  
  485.  
  486. proc package::queryWebForList {} {
  487.     global defaultAlphaDownloadSite remote::site PREFS
  488.     set sitename [dialog::value_for_variable defaultAlphaDownloadSite "Query which site?"]
  489.     set nm [file join ${PREFS} _pkgtemp]
  490.     set siteurl [set remote::site($sitename)]
  491.     
  492.     catch {file delete $nm}
  493.     message "Fetching remote list…"
  494.     set type [url::fetch $siteurl $nm]
  495.     package::okGotTheList $sitename
  496. }
  497.  
  498. ## 
  499.  # -------------------------------------------------------------------------
  500.  # 
  501.  # "package::okGotTheList" --
  502.  # 
  503.  #  Helper proc which we can also call if the listing was interrupted
  504.  #  half-way through.
  505.  # -------------------------------------------------------------------------
  506.  ##
  507. proc package::okGotTheList {{sitename ""}} {
  508.     global defaultAlphaDownloadSite remote::site PREFS remote::lastsite
  509.     if {$sitename == ""} {
  510.     if {[info exists remote::lastsite]} {
  511.         set sitename ${remote::lastsite}
  512.         unset remote::lastsite
  513.     } else {
  514.         set sitename [dialog::value_for_variable defaultAlphaDownloadSite "From which site did you get the list?"]
  515.     }
  516.     }
  517.     set type [lindex [url::parse [set remote::site($sitename)]] 0]
  518.     set nm [file join ${PREFS} _pkgtemp]
  519.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  520.     alertnote "It looks like that application returned control\
  521.       to me before the download was complete (otherwise there was an error)\
  522.       -- probably Netscape/IE.  When it's done, or if there was an error\
  523.       hit Ok."
  524.     }
  525.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  526.     dialog::alert "There was a problem fetching the list --- if it's still\
  527.       being downloaded (you hit Ok too early!), wait till it's done \
  528.       and then select 'Ok Got The List'\
  529.       from the internet updates menu."
  530.     set remote::lastsite $sitename
  531.     enableMenuItem -m internetUpdates "Ok, Got The List" on
  532.     error "Error fetching list of new packages"
  533.     } else {
  534.     enableMenuItem -m internetUpdates "Ok, Got The List" off
  535.     }
  536.     set fd [alphaOpen $nm "r"]
  537.     catch {set lines [split [read $fd] "\n\r"]}
  538.     close $fd
  539.     
  540.     if {[catch [list remote::process${type}Listing $lines] listing]} {
  541.     alertnote "Error interpreting list of new packages"
  542.     error "Error interpreting list of new packages"
  543.     }
  544.     message "Processing list…"
  545.     remote::processList $sitename $listing
  546.     message "Updated remote package information."
  547. }
  548.  
  549. proc package::active {pkg {text ""}} {
  550.     global global::features mode
  551.     if {([lsearch -exact ${global::features} $pkg] != -1) \
  552.       || ($mode != "" && ([lsearch -exact [mode::getFeatures $mode] $pkg] != -1))} {
  553.     if {[llength $text]} { return [lindex $text 0] } else {return 1 }
  554.     } else {
  555.     if {[llength $text]} { return [lindex $text 1] } else {return 0 }
  556.     }
  557. }
  558.  
  559. proc package::_editSite {{name ""} {loc ""}} {
  560.     if {$name == ""} {
  561.     set title "Name of new archive site"
  562.     set name "Ken's Alpha site"
  563.     set loc "ftp://ftp.ken.com/pub/Alpha/"
  564.     } else {
  565.     set title "Archive site name"
  566.     }
  567.     set y 10
  568.     set yb 105
  569.     set res [eval dialog -w 420 -h 135 \
  570.       [dialog::textedit $title $name 10 y 40] \
  571.       [dialog::textedit "URL for site" $loc 10 y 40] \
  572.       [dialog::okcancel 250 yb 0]]
  573.     if {[lindex $res 3]} { error "Cancel" } 
  574.     # cancel was pressed
  575.     return [lrange $res 0 1]    
  576. }
  577.  
  578.  
  579. proc package::addIndex {args} {
  580.     global index::feature pkg_file
  581.     cache::readContents index::feature
  582.     foreach f [concat $args] {
  583.     set pkg_file $f
  584.     message "scanning $f…"
  585.     catch {source $f}
  586.     }
  587.     cache::create index-extension "variable" index::feature
  588.     unset pkg_file
  589. }
  590. proc package::helpFile {pkg {pointer 0}} {
  591.     set v [alpha::package versions $pkg]
  592.     if {[lindex $v 0] == "mode"} {
  593.     set v [lindex $v 1]
  594.     if {$pointer} {
  595.         return "The '$pkg' package is implemented by $v mode, \
  596.           and has no separate help."
  597.     }
  598.     set pkg $v
  599.     }
  600.     if {![catch {alpha::package help $pkg} res]} {
  601.     set help [string trim [lindex $res 1]]
  602.     if {[lindex [split $help " \t"] 0] == "file"} {
  603.         if {$pointer} {
  604.         return "Help for this package is located in \
  605.           \"[lindex $help 1]\""
  606.         } else {
  607.         help::openFile [lindex $help 1]
  608.         }
  609.     } elseif {[string index $help 0] == "\["} {
  610.         if {$pointer} {
  611.         return "You can read help for this package \
  612.           by holding 'shift' when\ryou select its name in the menu."
  613.         } else {
  614.         uplevel \#0 [string range $help 1 \
  615.           [expr {[string length $help] - 2}]]
  616.         }
  617.     } else {
  618.         if {$pointer} {
  619.         return $help
  620.         } else {
  621.         new -n "* '$pkg' Help *" -info \
  622.           "\rHelp for package '$pkg', version \
  623.           [alpha::package versions $pkg]\r\r    $help"
  624.         message "Please wait: Colouring and marking the help file"
  625.         help::hyperiseEmailAddresses
  626.         help::hyperiseUrls
  627.         help::colourHeadingsEtc
  628.         message ""
  629.         }
  630.     }
  631.     return
  632.     }
  633.     if {!$pointer} {
  634.     alertnote "Sorry, there isn't a help file for that package. \
  635.       You should contact the package maintainer."
  636.     }
  637.     return
  638. }
  639.  
  640.  
  641. ## 
  642.  # -------------------------------------------------------------------------
  643.  # 
  644.  # "package::helpFilePresent" --
  645.  # 
  646.  #  Help files must be of the same name as the package (minus 'mode' or 
  647.  #  'menu'), but may have any combination of mode, menu, or help after
  648.  #  that name.  Whitespace is irrelevant.
  649.  # -------------------------------------------------------------------------
  650.  ##
  651. proc package::helpFilePresent {args} {
  652.     set res ""
  653.     cache::readContents index::help
  654.     foreach pkg $args {
  655.     lappend res [info exists index::help($pkg)]
  656.     }
  657.     return $res
  658. }
  659.  
  660. proc package::helpOrDescribe {pkg} {
  661.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  662.     if {$mods & 34} {
  663.         package::helpFile $pkg
  664.     } else {
  665.         package::describe $pkg
  666.     }
  667.     return 1
  668.     }
  669.     return 0
  670. }
  671.  
  672. # ◊◊◊◊ Specific to 'features' ◊◊◊◊ #
  673.  
  674. proc package::addRelevantMode {_feature mode} {
  675.     global index::feature
  676.     if {[info exists index::feature($_feature)]} {
  677.     if {[lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode] != -1} {
  678.         return
  679.     }
  680.     lappend oldm $mode
  681.     set index::feature($_feature) \
  682.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  683.     } else {
  684.     set index::feature($_feature) [list [list "mode" $mode] $mode]
  685.     }
  686. }
  687.  
  688. proc package::removeRelevantMode {_feature mode} {
  689.     global index::feature
  690.     if {[info exists index::feature($_feature)]} {
  691.     if {[set idx [lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode]] == -1} {
  692.         return
  693.     }
  694.     set oldm [lreplace $oldm $idx $idx ""]
  695.     set index::feature($_feature) \
  696.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  697.     }
  698. }
  699.  
  700. ## 
  701.  # -------------------------------------------------------------------------
  702.  # 
  703.  # "package::onOrOff" --
  704.  # 
  705.  #  Complicated procedure to accomplish a relatively simple task!
  706.  #  
  707.  #  Given the current mode (possibly ""), and the last mode, work out
  708.  #  what changes have to be made to the set of on/off features to
  709.  #  synchronise everything.
  710.  #  
  711.  #  This procedure is now only used by changeMode.
  712.  #  
  713.  #  Note that features which no longer exist are still returned by
  714.  #  this procedure.  Hence calling procedures should possibly
  715.  #  check whether the index::feature array entry exists.
  716.  # -------------------------------------------------------------------------
  717.  ##
  718. proc package::onOrOff {curMode {lastMode ""}} {
  719.     global global::features
  720.     set oldfeatures ""
  721.     set offfeatures ""
  722.     set onfeatures ""
  723.     set newfeatures ""
  724.     if {[mode::exists $curMode]} {
  725.     set pkgs [mode::getFeatures $curMode]
  726.     } else {
  727.     set pkgs {}
  728.     }
  729.     foreach m $pkgs {
  730.     if {[string index $m 0] == "-"} {
  731.         set m [string range $m 1 end]
  732.         if {[lsearch -exact ${global::features} $m] >= 0} {
  733.         lappend offfeatures $m
  734.         }
  735.     } else {
  736.         if {[lsearch -exact ${global::features} $m] < 0} {
  737.         lappend newfeatures $m
  738.         }
  739.     }
  740.     }
  741.     if {[mode::exists $lastMode]} {
  742.     foreach m [mode::getFeatures $lastMode] {
  743.         if {[string index $m 0] == "-"} {
  744.         set m [string range $m 1 end]
  745.         if {[lsearch -exact ${global::features} $m] >= 0} {
  746.             if {[set ip [lsearch -exact $offfeatures $m]] < 0} {
  747.             lappend newfeatures $m
  748.             } else {
  749.             set offfeatures [lreplace $offfeatures $ip $ip]
  750.             }
  751.         }
  752.         } else {
  753.         if {[lsearch -exact ${global::features} $m] < 0} {
  754.             lappend oldfeatures $m
  755.             if {[lsearch -exact $newfeatures $m] < 0} {
  756.             lappend offfeatures $m
  757.             }
  758.         }
  759.         }
  760.     }
  761.     }
  762.     foreach m $newfeatures {
  763.     if {[lsearch -exact $oldfeatures $m] < 0} {
  764.         lappend onfeatures $m
  765.     }
  766.     }
  767.     return [list $offfeatures $onfeatures]
  768. }
  769.  
  770. ## 
  771.  # -------------------------------------------------------------------------
  772.  # 
  773.  # "package::partition" --
  774.  # 
  775.  #  Return either 3 lists: menus, features and then modes, if 'mode'
  776.  #  is empty, or return 6 lists.
  777.  #  
  778.  #  In this second case we have 2 choices:
  779.  #  
  780.  #  (i) 'mode = global', we return: 
  781.  #  usual menus, other menus, {}, usual features, other features, {}
  782.  #  'Usual' means global, 'Other' means everything else.
  783.  #  (ii) 'mode = some given mode', we return: 
  784.  #  usual menus, general menus, other, usual features, general features, other
  785.  #  'Usual' means mode-specific, 'General' means global, 'Other' means
  786.  #  specific to other modes, or global-only
  787.  #  
  788.  #  Note: when we partition for a given mode, we remove all items
  789.  #  which are currently globally on.
  790.  # -------------------------------------------------------------------------
  791.  ##
  792. proc package::partition {{mode ""} {mfb 0} {ignore_flags 1}} {
  793.     global index::feature index::flags
  794.     set a ""
  795.     set b ""
  796.     set c ""
  797.     if {$mode == ""} {
  798.     # This is the case in which we just want everything.
  799.     foreach n [lsort -ignore [alpha::package names]] {
  800.         if {$ignore_flags && ([lsearch -exact ${index::flags} $n] != -1)} {
  801.         continue
  802.         }
  803.         if {[info exists index::feature($n)]} {
  804.         switch -- [lindex [set index::feature($n)] 2] {
  805.             "1" {
  806.             lappend a $n
  807.             }
  808.             default {
  809.             lappend b $n
  810.             }
  811.         }
  812.         } else {
  813.         lappend c $n
  814.         }
  815.     }
  816.     return [list $a $b $c]
  817.     } else {
  818.     # Now we either want only global items, or for the given mode
  819.     set d ""
  820.     set e ""
  821.     set f ""
  822.     set partition [array names index::feature]
  823.     if {$mode == "global"} {
  824.         set mode "global*"
  825.         set search "-glob"
  826.     } else {
  827.         set search "-exact"
  828.         global global::features
  829.         set partition [lremove -l $partition ${global::features}]
  830.     }        
  831.     foreach n [lsort -ignore $partition] {
  832.         if {$ignore_flags && ([lsearch -exact ${index::flags} $n] != -1)} {
  833.         continue
  834.         }
  835.         set ff [set index::feature($n)]
  836.         switch -- [lindex $ff 2] {
  837.         "1" {
  838.             if {$mfb == 2} {continue}
  839.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  840.             lappend a $n
  841.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  842.             lappend b $n
  843.             } elseif {[lindex $ff 1] != "global-only"} {
  844.             lappend c $n
  845.             }
  846.         }
  847.         "-1" {
  848.             # ignore auto-loading types
  849.         }
  850.         default {
  851.             if {$mfb == 1} {continue}
  852.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  853.             lappend d $n
  854.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  855.             lappend e $n
  856.             } elseif {[lindex $ff 1] != "global-only"} {
  857.             lappend f $n
  858.             }
  859.         }
  860.         }
  861.     }
  862.     return [list $a $b $c $d $e $f]
  863.     }    
  864. }
  865.  
  866.  
  867. proc package::describe {pkg {return 0}} {
  868.     set info [alpha::package info $pkg]
  869.     set type [lindex $info 0]
  870.     set v [alpha::package versions $pkg]
  871.     if {[lindex $v 0] == "mode"} {
  872.     set v [lindex $v 1]
  873.     set msg "Package '$pkg', designed for use by $v mode is a"
  874.     } else {
  875.     set msg "Package '$pkg', version $v is a"
  876.     }
  877.     
  878.     switch -- $type {
  879.     "feature" {
  880.         switch -- [lindex $info 3] {
  881.         "1" {
  882.             append msg " menu, and is "
  883.             global global::menus
  884.             if {![package::active $pkg]} {
  885.             append msg "not "
  886.             }
  887.             append msg "in use."
  888.         }
  889.         "-1" {
  890.             append msg "n autoloading $type."
  891.         }
  892.         default {
  893.             append msg " $type, and is [package::active $pkg {active inactive}]."
  894.         }
  895.         }
  896.     }
  897.     "mode" {
  898.         append msg " $type; modes are always active."
  899.     }
  900.     }
  901.     global index::maintainer
  902.     cache::readContents index::maintainer
  903.     if {[info exists index::maintainer($pkg)]} {
  904.     set p [lindex [set index::maintainer($pkg)] 1]
  905.     append msg "\rMaintainer: [lindex $p 0], [lindex $p 1]\r"
  906.     append msg [lindex $p 2]
  907.     }
  908.     catch {unset index::maintainer}
  909.     if {$return} {
  910.     return $msg
  911.     }
  912.     # let package tell us where its prefs are stored.
  913.     global alpha::prefs
  914.     if {[info exists alpha::prefs($pkg)]} {
  915.     set pkgpref [set alpha::prefs($pkg)]
  916.     } else {
  917.     set pkgpref $pkg
  918.     }
  919.     global ${pkgpref}modeVars
  920.     if {[array exists ${pkgpref}modeVars]} {
  921.     append msg "\r\r" [mode::describeVars $pkg $pkgpref]
  922.     new -n "* <$pkg> description *" -m Tcl -info $msg
  923.     } else {
  924.     alertnote $msg
  925.     }
  926. }
  927.  
  928. ## 
  929.  # -------------------------------------------------------------------------
  930.  # 
  931.  # "package::deactivate" --
  932.  # 
  933.  #  Turns off all the packages given.  This procedure must never throw an
  934.  #  error to its caller.
  935.  # -------------------------------------------------------------------------
  936.  ##
  937. proc package::deactivate {args} {
  938.     global index::feature alpha::noMenusYet
  939.     foreach pkg $args {
  940.     if {[info exists index::feature($pkg)]} {
  941.         set info [set index::feature($pkg)]
  942.         if {[lindex $info 2] == 1} {
  943.         global $pkg
  944.         if {![info exists alpha::noMenusYet]} {
  945.             try::level \#0 "removeMenu \$$pkg\n[lindex $info 5]" \
  946.               -reporting log -while "deactivating $pkg"
  947.             continue
  948.         }
  949.         }
  950.         try::level \#0 [lindex $info 5] -reporting log -while "deactivating $pkg"
  951.     } else {
  952.         # This happens if the user completely removes a feature,
  953.         # while some mode still wants to use it (e.g. particularly
  954.         # with menus).
  955.         alertnote "Something is trying to activate the '$pkg' feature,\
  956.           which no longer exists.  I will remove all references to it."
  957.         mode::removeFeatureFromAll $pkg
  958.     }
  959.     }
  960. }
  961.  
  962. ## 
  963.  # -------------------------------------------------------------------------
  964.  # 
  965.  # "package::activate" --
  966.  # 
  967.  #  Turns on all the packages given.  This procedure must never throw an
  968.  #  error to its caller.
  969.  # -------------------------------------------------------------------------
  970.  ##
  971. proc package::activate {args} {
  972.     global index::feature alpha::noMenusYet
  973.     foreach pkg $args {
  974.     if {[info exists index::feature($pkg)]} {
  975.         set info [set index::feature($pkg)]
  976.         if {[set init [lindex $info 3]] != ""} {
  977.         message "Loading package '$pkg'…"
  978.         try::level \#0 $init -reporting log -while "initialising $pkg" 
  979.         set index::feature($pkg) [lreplace [set index::feature($pkg)] 3 3 ""]
  980.         }
  981.         if {[lindex $info 2] == 1} {
  982.         global $pkg
  983.         if {![info exists alpha::noMenusYet]} {
  984.             try::level \#0 "[lindex $info 4]\ninsertMenu \$$pkg" \
  985.               -reporting log -while "activating $pkg"
  986.             continue
  987.         }
  988.         }
  989.         try::level \#0 [lindex $info 4] -reporting log -while "activating $pkg"
  990.     } else {
  991.         # This happens if the user completely removes a feature,
  992.         # while some mode still wants to use it (e.g. particularly
  993.         # with menus).
  994.         alertnote "Something is trying to activate the '$pkg' feature,\
  995.           which no longer exists.  I will remove all references to it."
  996.         mode::removeFeatureFromAll $pkg
  997.     }
  998.     }
  999. }
  1000.  
  1001. ## 
  1002.  # -------------------------------------------------------------------------
  1003.  # 
  1004.  # "package::initialise" --
  1005.  # 
  1006.  #  Initialises all the packages given.  This procedure must never throw an
  1007.  #  error to its caller.
  1008.  # -------------------------------------------------------------------------
  1009.  ##
  1010. proc package::initialise {args} {
  1011.     global index::feature
  1012.     foreach pkg $args {
  1013.     if {[info exists index::feature($pkg)]} {
  1014.         if {[set init [lindex [set index::feature($pkg)] 3]] != ""} {
  1015.         message "Loading package '$pkg'…"
  1016.         try::level \#0 $init -reporting log -while "initialising $pkg" 
  1017.         set index::feature($pkg) [lreplace [set index::feature($pkg)] 3 3 ""]
  1018.         }
  1019.     } else {
  1020.         # This happens if the user completely removes a feature,
  1021.         # while some mode still wants to use it (e.g. particularly
  1022.         # with menus).
  1023.         alertnote "Something is trying to activate the '$pkg' feature,\
  1024.           which no longer exists.  I will remove all references to it."
  1025.         mode::removeFeatureFromAll $pkg
  1026.     }
  1027.     }
  1028. }
  1029.  
  1030. proc package::uninstall {} {
  1031.     cache::readContents index::uninstall
  1032.     if {![llength [set pkgs [array names index::uninstall]]]} {
  1033.     alertnote "I don't know how to uninstall anything."
  1034.     return
  1035.     }
  1036.     set pkgs [listpick -p "Permanently remove which packages/modes/menus?" -l [lsort -ignore $pkgs]]
  1037.     if {![llength $pkgs]} { return }
  1038.     if {![dialog::yesno "Are you absolutely sure you want to uninstall [join $pkgs {, }]?"]} { 
  1039.     return 
  1040.     }
  1041.     global pkg_file HOME
  1042.     foreach pkg $pkgs {
  1043.     set pkg_file [subst [lindex [set index::uninstall($pkg)] 1]]
  1044.     set script [lindex [set index::uninstall($pkg)] 2]
  1045.     if {[regexp "rm -r\[^\r\n\]*" $script check]} {
  1046.         if {![dialog::yesno "The uninstaller for $pkg contains a\
  1047.           recursive removal command '$check'. Do you want to do this?"]} { 
  1048.         return 
  1049.         }
  1050.     }
  1051.     if {[catch "uplevel \#0 [list $script]"]} {
  1052.         alertnote "The uninstaller for $pkg had problems!"
  1053.     }
  1054.     }
  1055.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  1056.     quit
  1057.     }
  1058.     if {[dialog::yesno "All indices must then be rebuilt.\rShall I do this for you?"]} {
  1059.     alpha::rebuildPackageIndices
  1060.     rebuildTclIndices
  1061.     } else {
  1062.     alertnote "This will probably cause problems."
  1063.     }
  1064.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  1065.     quit
  1066.     }
  1067. }
  1068.  
  1069. ## 
  1070.  # -------------------------------------------------------------------------
  1071.  # 
  1072.  # "date::isOlder" --
  1073.  # 
  1074.  #  {Aug 22 1996} {Mar 26 22:17}
  1075.  #  
  1076.  # We assume the format is 'Month Day Year' or 'Month Day Time', where
  1077.  # a time is distinguished by the presence of a colon.  Months have
  1078.  # to be the standard three letter abbreviation (seems ok for all
  1079.  # ftp and http servers I've come across)
  1080.  # -------------------------------------------------------------------------
  1081.  ##
  1082. proc date::isOlder {a b} {
  1083.     if {$a == $b} { return 0 }
  1084.     regexp {(\w+)[ \t]+(\w+)[ \t]+((\w|:)+)} $a "" am ad ay
  1085.     regexp {(\w+)[ \t]+(\w+)[ \t]+((\w|:)+)} $b "" bm bd by
  1086.     # check year
  1087.     regexp {[0-9]+$} [lindex [mtime [now] abbrev] 0] thisy
  1088.     if {$ay == $thisy} { set ay "00:00" }
  1089.     if {$by == $thisy} { set by "00:00" }
  1090.     set a_ist [regexp : $ay]
  1091.     set b_ist [regexp : $by]
  1092.     if {!$a_ist && !$b_ist} {
  1093.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  1094.     }
  1095.     if {$a_ist && !$b_ist} { return 0 }
  1096.     if {!$a_ist && $b_ist} { return 1 }
  1097.     # both are a year or both are times and both in last year
  1098.     set months {Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
  1099.     # check we don't have a year wrap-around problem
  1100.     set now_m [mtime [now] month]
  1101.     set now_d [mtime [now] day]
  1102.     set am [lsearch $months $am]
  1103.     set bm [lsearch $months $bm]
  1104.     set aprev [expr {($now_m < $am || ($now_m == $am && $now_d < $ad))}]
  1105.     set bprev [expr {($now_m < $bm || ($now_m == $bm && $now_d < $bd))}]
  1106.     if {$aprev && !$bprev} {return 1}
  1107.     if {!$aprev && $bprev} {return 0}
  1108.     # both in same year: continue
  1109.     if {$am < $bm} { return 1 } elseif {$bm < $am} { return 0 }
  1110.     if {$ad < $bd} { return 1 } elseif {$bd < $ad} { return 0 }
  1111.     if {$a_ist && $b_ist} {
  1112.     regsub {:} $ay {.} ay
  1113.     regsub {:} $by {.} by
  1114.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  1115.     } 
  1116.     # same !
  1117.     return 0
  1118. }
  1119.  
  1120.  
  1121. # ◊◊◊◊ Handle remote menu ◊◊◊◊ #
  1122. proc package::menuProc {menu item} {
  1123.     global remote::site modifiedArrVars defaultAlphaDownloadSite
  1124.     switch -- $item {
  1125.     "Describe A Package" {
  1126.         set pkg [dialog::optionMenu "Describe which package?" \
  1127.           [lsort -ignore [alpha::package names]]]
  1128.         package::describe $pkg
  1129.     }
  1130.     "Read Help For A Package" {
  1131.         set pkg [dialog::optionMenu "Read help for which package?" \
  1132.           [lsort -ignore [alpha::package names]]]
  1133.         package::helpFile $pkg
  1134.     }
  1135.     "Uninstall Some Packages" {
  1136.         package::uninstall
  1137.     }
  1138.     "rebuildPackageIndex" {
  1139.         alpha::rebuildPackageIndices
  1140.     }
  1141.     "listPackages" {
  1142.         global::listPackages
  1143.     }
  1144.     "installBugFixesFrom" {
  1145.         # this item isn't in the menu by default anymore.
  1146.         set f [getfile "Select a bug-fix file…"]
  1147.         procs::patchOriginalsFromFile $f 1
  1148.     }
  1149.     "Update List From A Web Archive Site" {
  1150.         package::queryWebForList
  1151.     }
  1152.     "Ok, Got The List" {
  1153.         package::okGotTheList
  1154.     }
  1155.     "Add Web Or Ftp Archive Site" {
  1156.         array set remote::site [package::_editSite]
  1157.         lappend modifiedArrVars remote::site
  1158.     }
  1159.     "Edit Web Or Ftp Archive Site" {
  1160.         set sitename [dialog::optionMenu "Edit which site?" \
  1161.           [lsort -ignore [array names remote::site]]]
  1162.         
  1163.         array set remote::site \
  1164.           [package::_editSite $sitename [set remote::site($sitename)]]
  1165.         lappend modifiedArrVars remote::site
  1166.     }
  1167.     "Remove Web Or Ftp Archive Site" {
  1168.         set sitename [dialog::optionMenu "Remove which site?" \
  1169.           [lsort -ignore [array names remote::site]]]
  1170.         unset remote::site($sitename)
  1171.         lappend modifiedArrVars remote::site
  1172.     }
  1173.     "Describe Item" {
  1174.         alertnote "Select one of the packages, and I'll tell you\
  1175.           when it was last modified, and from where it would be downloaded."
  1176.     }
  1177.     "Ignore Item" {
  1178.         alertnote "'Ignoring' a package tells me to remove it from\
  1179.           new and updated package lists.  It'll still be listed lower\
  1180.           down in the menu"
  1181.     }
  1182.     "Select Item To Download" {
  1183.         alertnote "Select one of the packages, and it will be\
  1184.           downloaded from its site on the internet, decompressed\
  1185.           and installed."
  1186.     }
  1187.     default {
  1188.         remote::get $item
  1189.     }
  1190.     }
  1191.     
  1192. }
  1193.  
  1194.  
  1195. proc package::makeUpdateMenu {} {
  1196.     global remote::listing
  1197.     set l [list \
  1198.       "Update List From A Web Archive Site…" \
  1199.       "(Ok, Got The List" \
  1200.       "<E<SRemove Web Or Ftp Archive Site…" \
  1201.       "<S<BEdit Web Or Ftp Archive Site…" \
  1202.       "<SAdd Web Or Ftp Archive Site…" "(-" \
  1203.       "<S[menu::itemWithIcon {Describe Item} 81]" \
  1204.       "<S<U[menu::itemWithIcon {Ignore Item} 81]" \
  1205.       "<S[menu::itemWithIcon {Select Item To Download} 81]" ]
  1206.     foreach a ${remote::listing} {
  1207.     set type [lindex $a 1]
  1208.     regsub -all {\.(sea|tar|gz|zip|sit|bin|hqx)} [lindex $a 2] "" name
  1209.     lappend [lindex {other gone new uptodate update} [expr {$type + 2}]] $name
  1210.     if {$type == -1} {
  1211.         lappend disable $name
  1212.     }
  1213.     }
  1214.     if {[info exists update]} {
  1215.     lappend l "(-" "/\x1e(Updated items^[text::Ascii 79 1]"
  1216.     eval lappend l [lsort -ignore $update]
  1217.     }
  1218.     if {[info exists new]} {
  1219.     lappend l "(-" "/\x1e(New items^[text::Ascii 79 1]"
  1220.     eval lappend l [lsort -ignore $new]
  1221.     }
  1222.     if {[info exists uptodate]} {
  1223.     lappend l "(-" "(Current items"
  1224.     eval lappend l [lsort -ignore $uptodate]
  1225.     }
  1226.     if {[info exists other]} {
  1227.     lappend l "(-" "(Other items"
  1228.     eval lappend l [lsort -ignore $other]
  1229.     }
  1230.     if {[info exists gone]} {
  1231.     lappend l "(-" "(Vanished items"
  1232.     eval lappend l [lsort -ignore $gone]
  1233.     }
  1234.     Menu -n "internetUpdates" -m -p package::menuProc $l
  1235.     if {[info exists disable]} {
  1236.     foreach a $disable {
  1237.         enableMenuItem "internetUpdates" $a off
  1238.     }
  1239.     }
  1240. }
  1241.  
  1242. proc remote::processftpListing {lines} {
  1243.     set files {}
  1244.     foreach f [lrange [lreplace $lines end end] 1 end] {
  1245.     set nm [lindex $f end]
  1246.     if {[string length $nm]} {
  1247.         if {[string match "d*" $f]} {
  1248.         #lappend files "$nm/"
  1249.         } else {
  1250.         regexp {[A-Z].*$} [lreplace $f end end] time
  1251.         set date [lindex $time end]
  1252.         if {[regexp : $date] || ![regexp {^19[89][0-5]$} $date]} {
  1253.             # reject anything pre 1996
  1254.             lappend files [list $nm $time]
  1255.         }
  1256.         }
  1257.     }
  1258.     }
  1259.     return $files
  1260. }
  1261.  
  1262. ## 
  1263.  # -------------------------------------------------------------------------
  1264.  # 
  1265.  # "remote::processhttpListing" --
  1266.  # 
  1267.  #  Extract all things like  <A HREF="/~vince/pub/">Parent Directory</A>
  1268.  #  followed by a date.  Massage the date into 'Month day year'.
  1269.  #  
  1270.  #  I don't know if this will work for all http servers!  It works for
  1271.  #  mine.
  1272.  # -------------------------------------------------------------------------
  1273.  ##
  1274. proc remote::processhttpListing {lines} {
  1275.     set files {}
  1276.     foreach f $lines {
  1277.     if {[regexp "<A HREF=\"(\[^\"\]*)\">\[^<\]*</A>\[ \t\]*(\[^ \t\]+)\[ \t\]" $f "" name date]} {
  1278.         if {![regexp {/$} $name]} {
  1279.         if {![regexp {[89][0-5]$} $date]} {
  1280.             # reject anything pre 1996
  1281.             set date [split $date -]
  1282.             set md "[lindex $date 1] [lindex $date 0] "
  1283.             append md [expr {[lindex $date 2] < 80 ? 20 : 19}]
  1284.             append md [lindex $date 2]
  1285.             lappend files [list $name $md]
  1286.         }
  1287.         }
  1288.     }
  1289.     }
  1290.     return $files
  1291. }
  1292.  
  1293. proc remote::versionOneNewer {one two} {
  1294.     return 1
  1295. }
  1296.  
  1297. proc remote::processList {sitename {l ""}} {
  1298.     global remote::listing modifiedVars
  1299.     # removed vanished items from the menu
  1300.     regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} $l "" ll
  1301.     foreach i ${remote::listing} {
  1302.     if {[string match "*${sitename}*" $i]} {
  1303.         regsub -all {(\.|-)([0-9]+([a-zA-Z][0-9]+)?)} \
  1304.           [set ii [lindex $i 2]] "" ii
  1305.         if {[lsearch -glob $ll "$ii *"] == -1} {
  1306.         # it's vanished
  1307.         lappend removed $i
  1308.         lappend _removed [lindex $i 0]
  1309.         }
  1310.     }
  1311.     }
  1312.     if {[info exists removed]} {
  1313.     set remote::listing [lremove -l ${remote::listing} $removed]
  1314.     }
  1315.     # process new items
  1316.     foreach i $l {
  1317.     set namepart [lindex $i 0]
  1318.     set timepart [lindex $i 1]
  1319.     regsub -all {\.(sea|tar|tgz|gz|zip|sit|bin|hqx)} $namepart "" name
  1320.     regsub -all {(\.|-|_)[0-9]+([a-zA-Z][0-9]+)?} $name "" name
  1321.     if {[set idx [lsearch -glob ${remote::listing} "[quote::Find ${name}] *"]] != -1} {
  1322.         # update old item
  1323.         set item [lindex ${remote::listing} $idx]
  1324.         if {[lindex $item 2] != $namepart} {
  1325.         # it's changed
  1326.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1327.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1328.         lappend _updated $name
  1329.         } elseif {[date::isOlder [lindex $item 3] $timepart]} {
  1330.         # date has changed
  1331.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1332.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1333.         lappend _updated $name
  1334.         }
  1335.     } else {
  1336.         # new package
  1337.         lappend remote::listing [list $name 0 $namepart $timepart $sitename]
  1338.         lappend _new $name
  1339.     }
  1340.     
  1341.     }
  1342.     lappend modifiedVars remote::listing
  1343.     package::makeUpdateMenu
  1344.     ensureset _updated "none"
  1345.     ensureset _new "none"
  1346.     ensureset _removed "none"
  1347.     if {[catch {alertnote "Remote information, NEW: $_new, UPDATED: $_updated, REMOVED: ${_removed}."}]} {
  1348.     alertnote "Remote information, [llength $_new] new, [llength $_updated] updated and [llength $_removed] packages removed."
  1349.     }
  1350. }
  1351. proc remote::updateDatabase {idx val} {
  1352.     global remote::listing
  1353.     set item [lindex ${remote::listing} $idx]
  1354.     if {[lindex $item 1] != $val} {
  1355.     # it's changed
  1356.     set item [lreplace $item 1 1 $val]
  1357.     set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1358.     }
  1359. }
  1360.  
  1361. proc remote::pkgIndex {name} { 
  1362.     global remote::listing
  1363.     if {[set i [lsearch -glob ${remote::listing} "[quote::Find ${name}] *"]] == -1} {
  1364.     set i [lsearch -glob ${remote::listing} \
  1365.       "[quote::Find [string toupper [string index ${name} 0]][string range $name 1 end]] *"]
  1366.     }
  1367.     return $i
  1368. }
  1369.  
  1370. proc remote::pkgDetails {name} { 
  1371.     global remote::listing
  1372.     set idx [lsearch -glob ${remote::listing} "[quote::Find ${name}] *"]
  1373.     return [lindex ${remote::listing} $idx]
  1374. }
  1375.  
  1376. proc remote::get {pkg} {
  1377.     global remote::listing HOME remote::site downloadFolder file::separator
  1378.     # get pkg
  1379.     if {[set idx [remote::pkgIndex $pkg]] == -1} {
  1380.     regsub -all {(\.|-|_)[0-9]+([a-zA-Z][0-9]+)?} $pkg "" pkg
  1381.     if {[set idx [remote::pkgIndex $pkg]] == -1} {
  1382.         alertnote "Sorry, I don't know from where to download that package."
  1383.         error ""
  1384.     }
  1385.     }
  1386.     set item [lindex ${remote::listing} $idx]
  1387.     
  1388.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  1389.     if {$mods & 34} {
  1390.         # just shift key demote the item in the hierarchy
  1391.         set itm [lindex $item 1]
  1392.         if {$itm == 0 || $itm == 2} { set itm 1 } else { set itm -2 }
  1393.         set item [lreplace $item 1 1 $itm]
  1394.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1395.         global modifiedVars
  1396.         lappend modifiedVars remote::listing
  1397.         package::makeUpdateMenu
  1398.         message "Package '$pkg' demoted."
  1399.         return
  1400.     } else {
  1401.         # describe the item
  1402.         alertnote "File '[lindex $item 2]', last modified [lindex $item 3], to be downloaded from [lindex $item 4], at [set remote::site([lindex $item 4])]"
  1403.         return
  1404.     }
  1405.     }
  1406.     set file [lindex $item 2]
  1407.     set sitename [lindex $item 4]
  1408.     # get the file
  1409.     if {![file exists $downloadFolder] || ![file isdirectory $downloadFolder]} {
  1410.     alertnote "Your Download Folder does not exist.  I'll download to Alpha's home directory."
  1411.     set downloadFolder $HOME
  1412.     }
  1413.     if {[catch {url::fetchFrom [set remote::site($sitename)] ${downloadFolder}${file::separator} $file} err]} {
  1414.     alertnote "Fetch error '$err'"
  1415.     error ""
  1416.     }
  1417.     set ff [file join $downloadFolder $file]
  1418.     if {![file exists $ff] || (![file writable $ff]) || (![file size $ff])} {
  1419.     dialog::alert "It looks like that application returned control to\
  1420.       me before the download was complete (otherwise there was an error)\
  1421.       -- probably Netscape/IE.\r\rWhen it's done, or if there was an error\
  1422.       hit Ok."
  1423.     }
  1424.     # update database
  1425.     remote::updateDatabase $idx 1
  1426.     package::makeUpdateMenu
  1427.     # decompress it
  1428.     file::decompress [file join ${downloadFolder} $file]
  1429.     if {![regexp {^(.*)\.[^.]*$} $file "" filepre]} {set filepre $file}
  1430.     # install
  1431.     set files [glob -types TEXT -nocomplain -path [file join ${downloadFolder} ${filepre}] -- *]
  1432.     set realfiles {}
  1433.     foreach f $files {
  1434.     if {![file isdirectory $f]} {
  1435.         lappend realfiles $f
  1436.     }
  1437.     }
  1438.     set files $realfiles
  1439.     if {[llength $files] == 0} {
  1440.     # look for directory
  1441.     set dirs [glob -nocomplain -types d -path [file join ${downloadFolder} ${filepre}] -- *]
  1442.     if {[llength $dirs] == 1} {
  1443.         set local [lindex $dirs 0]
  1444.         set files [lunique [glob -types TEXT -nocomplain -dir $local -- "*\[i|I\]{nstall,NSTALL}"]]
  1445.     } else {
  1446.         set files ""
  1447.         set local $downloadFolder
  1448.     }
  1449.     }
  1450.     if {[llength $files] == 0} {
  1451.     alertnote "I can't find a suitable, unique install file.  You must find it yourself."
  1452.     # open dir in finder
  1453.     file::showInFinder $local
  1454.     return
  1455.     }
  1456.     if {[llength $files] > 1} {
  1457.     set f [listpick -p "Which file is the installer?" $files]
  1458.     } else {
  1459.     set f [lindex $files 0]
  1460.     }
  1461.     set f [file nativename $f]
  1462.     edit $f
  1463.     # If this wasn't auto-installed by the 'edit' command
  1464.     # (in which case the window would have been killed already)
  1465.     if {[win::Current] == $f} {
  1466.     global mode
  1467.     if {$mode != "Inst"} {
  1468.         alertnote "I don't know what to do with this package from here."
  1469.     } else {
  1470.         if {[dialog::yesno "You can install this extension from the install menu.\rShall I do that for you?"]} {
  1471.         install::installThisPackage
  1472.         }
  1473.     }
  1474.     }
  1475. }
  1476.  
  1477.  
  1478.  
  1479.  
  1480.  
  1481.  
  1482.  
  1483.  
  1484.  
  1485.